Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/FetchNews 1.0.0b/source/FetchNews.p

Text File | 1993-03-12 | 10.6 KB | 453 lines | [TEXT/PJMM]

program FetchNews;

    uses
        TCPStuff, TCPConnections, MyTypes, MyUtils, MyBufferedTCP, MyHandleFile, MyFileSystemUtils;

    const
        bad_rn = -32768;
        nntp_port = 119;
        text_creator = 'ttxt';
        global_strh_id = 200;
        data_filename_index = 1;
        demo_name_index = 2;
        active_index = 3;
        initial_command_index = 4;
        data_strh_id = 128;
        host_index = 1;
        groups_index = 2;

    var
        error: OSErr;
        quitNow: boolean;
        buffer: TCPBuffer;
        state: (S_None, S_WaitingForHello, S_WaitingOnInitialCommand, S_GettingList, {}
            S_WaitingForGroupReply, S_WaitingForArticleReply, S_WaitingForDot, S_Quiting);
        time_of_last_action: longInt;
        nntp_connection: connectionIndex;
        nntp_tcpc: TCPConnectionPtr;
        list_hf: HandleFile;
        demo_vrn: integer;
        demo_dirID: longInt;
        transfering: boolean;
        transfering_refnum: integer;
        article_dirID: longInt;
        article_startID, article_curID, article_endID: longInt;

    function GetIndStr (id, index: integer): str255;
        var
            s: str255;
    begin
        GetIndString(s, id, index);
        GetIndStr := s;
    end;

    function GetGlobalStr (index: integer): str255;
    begin
        GetGlobalStr := GetIndStr(global_strh_id, index);
    end;

    procedure FailError (oe: OSErr);
    begin
        if error = noErr then
            error := oe;
    end;

    function NoError (oe: OSErr): boolean;
    begin
        if error = noErr then
            error := oe;
        NoError := error = noErr;
    end;

    function MakeDirectory (name: str255; parID: longInt; var dirID: longInt): OSErr;
        var
            pb: CInfoPBRec;
            oe: OSErr;
            dummy: longInt;
    begin
        oe := DirCreate(demo_vrn, parID, name, dummy);
        MakeDirectory := MyGetCatInfo(demo_vrn, parID, name, 0, pb);
        dirID := pb.ioDirID;
    end;

    procedure SendLine (s: str255);
        var
            oe: OSErr;
    begin
{    writeln('>', s);}
        s := concat(s, cr, lf);
        oe := TCPSendAsync(nntp_tcpc, @s[1], length(s), true, nil);
    end;

    procedure GetWordDel (var line, word: str255; del: char);
        var
            p: integer;
    begin
        p := Pos(del, line);
        if p > 0 then begin
            word := copy(line, 1, p - 1);
            line := copy(line, p + 1, 255);
        end
        else begin
            word := line;
            line := '';
        end;
    end;

    procedure GetWord (var line, word: str255);
    begin
        GetWordDel(line, word, ' ');
    end;

    function FirstWord (line: str255): str255;
        var
            word: str255;
    begin
        GetWord(line, word);
        FirstWord := word;
    end;

    function Match (s, pattern: str255): boolean;
    begin
        if pattern[length(pattern)] = '*' then begin
            Match := IUEqualString(copy(s, 1, length(pattern) - 1), copy(pattern, 1, length(pattern) - 1)) = 0;
        end
        else begin
            Match := IUEqualString(s, pattern) = 0;
        end;
    end;

    function GoodGroup (s: str255): boolean;
        var
            g: str255;
            i: integer;
    begin
        GoodGroup := false;
        i := groups_index;
        g := GetIndStr(data_strh_id, i);
        while g <> '' do begin
            if Match(s, g) then begin
                GoodGroup := true;
                leave;
            end;
            i := i + 1;
            g := GetIndStr(data_strh_id, i);
        end;
    end;

    function WriteHandleToFile (var fs: FSSpec; h: handle; fcreator, ftype: OSType): OSErr;
        var
            oe, ooe: OSErr;
            count: longInt;
            refnum: integer;
    begin
        ooe := HCreate(fs.vRefNum, fs.parID, fs.name, fcreator, ftype);
        oe := HOpen(fs.vRefNum, fs.parID, fs.name, fsRdWrPerm, refnum);
        if oe = noErr then begin
            ooe := SetEOF(refnum, 0);
            count := GetHandleSize(h);
            oe := FSWrite(refnum, count, h^); { Anyone with sufficent paranoia would lock this handle! }
            if (oe = noErr) and (count <> GetHandleSize(h)) then
                oe := eofErr;
            ooe := FSClose(refnum);
        end;
        WriteHandleToFile := oe;
    end;

    procedure CleanOutDirectory;
        var
            index, i: integer;
            oe, ooe: OSErr;
            pb: CInfoPBRec;
            name: str255;
            delete_it: boolean;
            n: longInt;
    begin
        index := 1;
        repeat
            oe := MyGetCatInfo(demo_vrn, article_dirID, name, index, pb);
            if oe = noErr then begin
                delete_it := true;
                for i := 1 to length(name) do begin
                    if (name[i] < '0') or (name[i] > '9') then begin
                        delete_it := false;
                        leave;
                    end;
                end;
                if delete_it then begin
                    n := StrToNum(name);
                    delete_it := (n < article_startID) | (n > article_endID);
                end;
                if delete_it then begin
                    ooe := HDelete(demo_vrn, article_dirID, name);
                    delete_it := ooe = noErr;
                end;
                if not delete_it then
                    index := index + 1;
            end;
        until (oe <> noErr);
    end;

    procedure HandleLine (line: str255);
        procedure DoQuit;
        begin
            SendLine('QUIT');
            state := S_Quiting;
        end;

        procedure StartGroup;
            var
                line, group, dir, s: str255;
        begin
            if not ReadFromHandleFile(list_hf, line) | (line = '.') then begin
                DoQuit;
            end
            else begin
                GetWord(line, group);
                GetWord(line, s);
                article_endID := StrToNum(s);
                GetWord(line, s);
                article_startID := StrToNum(s);
                article_curID := article_startID;
                article_dirID := demo_dirID;
                s := group;
                while (s <> '') & (error = noErr) do begin
                    GetWordDel(s, dir, '.');
                    FailError(MakeDirectory(dir, article_dirID, article_dirID));
                end;
                if error = noErr then begin
                    CleanOutDirectory;
                    SendLine(concat('GROUP ', group));
                    state := S_WaitingForGroupReply;
                end;
            end;
        end;

        procedure StartArticle;
            var
                name: str63;
                fi: FInfo;
                started: boolean;
        begin
            started := false;
            while not started and (article_curID <= article_endID) do begin
                if HGetFInfo(demo_vrn, article_dirID, NumToStr(article_curID), fi) = noErr then begin
                    article_curID := article_curID + 1;
                end
                else begin
                    SendLine(concat('ARTICLE ', NumToStr(article_curID)));
                    state := S_WaitingForArticleReply;
                    started := true;
                end;
            end;
            if not started then
                StartGroup;
        end;

        var
            active_fs: FSSpec;
            oe: OSErr;
    begin
        case state of
            S_WaitingForHello:  begin
                if line[1] = '2' then begin
                    SendLine(GetGlobalStr(initial_command_index));
                    state := S_WaitingOnInitialCommand;
                end
                else begin
                    FailError(-3);
                    DoQuit;
                end;
            end;
            S_WaitingOnInitialCommand:  begin
                SendLine('LIST');
                state := S_GettingList;
            end;
            S_GettingList:  begin
                if line = '.' then begin
                    WriteToHandleFile(list_hf, line);
                    oe := MyFSMakeFSSpec(demo_vrn, demo_dirID, GetGlobalStr(active_index), active_fs);
                    if oe = fnfErr then
                        oe := noErr;
                    if NoError(oe) then begin
                        if NoError(WriteHandleToFile(active_fs, list_hf.data, text_creator, 'TEXT')) then begin
                            list_hf.pos := 0;
                            StartGroup;
                        end;
                    end;
                    if error <> noErr then
                        DoQuit;
                end
                else if GoodGroup(FirstWord(line)) then begin
                    WriteToHandleFile(list_hf, line);
                end;
            end;
            S_WaitingForGroupReply:  begin
                if line[1] = '2' then begin
                    StartArticle;
                end
                else begin
                    StartGroup;
                end;
            end;
            S_WaitingForArticleReply:  begin
                if line[1] = '2' then begin
                    oe := HCreate(demo_vrn, article_dirID, NumToStr(article_curID), text_creator, 'TEXT');
                    oe := HOpen(demo_vrn, article_dirID, NumToStr(article_curID), fsRdWrPerm, transfering_refnum);
                    if oe <> noErr then begin
                        transfering_refnum := bad_rn; { best we can do, oh well }
                        FailError(oe);
                    end;
                    transfering := true;
                    state := S_WaitingForDot;
                end
                else begin
                    article_curID := article_curID + 1;
                    StartArticle;
                end;
            end;
            S_WaitingForDot:  begin
                oe := FSClose(transfering_refnum);
                transfering := false;
                article_curID := article_curID + 1;
                StartArticle;
            end;
            S_Quiting:  begin
                state := S_None;
                CloseConnection(nntp_connection);
            end;
            otherwise
                ;
        end;
    end;

    procedure WNE;
        var
            dummy: boolean;
            er: eventRecord;
    begin
        dummy := WaitNextEvent(everyEvent, er, 5, nil);
    end;

    procedure HCE;
        var
            cer: connectionEventRecord;
            line: str255;
            finished: boolean;
    begin
        if GetConnectionEvent(any_connection, cer) then begin
            with cer do begin
                case event of
                    C_Found:  begin
                        if not NoError(NewActiveConnection(nntp_connection, Default_TCPBUFFERSIZE, value, nntp_port, nil)) then
                            quitNow := true;
                    end;
                    C_SearchFailed:  begin
                        FailError(-2);
                        quitNow := true;
                    end;
                    C_Established:  begin
                        nntp_tcpc := cer.tcpc;
                        time_of_last_action := TickCount;
                        SetHeartBeat(connection, 30 * 60); { Heart beat every 30 seconds }
                        if not NoError(TBCreate(buffer, tcpc, 10000)) then begin
                            quitNow := true;
                            CloseConnection(connection);
                        end
                        else begin
                            state := S_WaitingForHello;
                        end;
                    end;
                    C_HeartBeat:  begin
                        if (TickCount - time_of_last_action) >= longInt(1) * 60 * 60 then begin
                            FailError(-4);
                            SetHeartBeat(connection, -1);
                            CloseConnection(connection);
                            quitNow := true;
                        end;
                    end;
                    C_CharsAvailable:  begin
                        TBReadChars(buffer, value);
                        while not transfering and TBGetLine(buffer, line) do begin
{    if (copy(line, 1, 3) <> 'mis') & (copy(line, 1, 3) <> 'sci') & (copy(line, 1, 3) <> 'alt') & (copy(line, 1, 3) <> 'com') & (copy(line, 1, 3) <> 'bit') & (copy(line, 1, 3) <> 'rec') then}
{    writeln('<', line);}
                            HandleLine(line);
                        end;
                        if transfering then begin
                            FailError(TBTransferTilDot(buffer, transfering_refnum, finished, 13));
                            if finished then
                                HandleLine('');
                        end;
                        if error <> noErr then
                            CloseConnection(connection);
                        time_of_last_action := TickCount;
                    end;
                    C_Closing:  begin
                        CloseConnection(connection);
                    end;
                    C_Closed:  begin
                        quitNow := true;
                    end;
                end;
            end;
        end;
    end;

    var
        app_resfile: integer;
        app_fs: FSSpec;

    procedure GetAppInfo;
        var
            pb: FCBPBRec;
            oe: OSErr;
    begin
        app_resfile := CurResFile;
        pb.ioNamePtr := @app_fs.name;
        pb.ioVRefNum := 0;
        pb.ioRefNum := app_resfile;
        pb.ioFCBIndx := 0;
        oe := PBGetFCBInfo(@pb, false);
        app_fs.vRefNum := pb.ioFCBVRefNum;
        app_fs.parID := pb.ioFCBParID;
    end;

    function GetDemoFolder: OSErr;
    begin
        demo_vrn := app_fs.vRefNum;
        GetDemoFolder := MakeDirectory(GetGlobalStr(demo_name_index), app_fs.parID, demo_dirID);
    end;

    var
        dataresfile: integer;
        host: str255;
        cp: connectionIndex;
begin
    quitNow := false;
    state := S_None;
    transfering := false;
    GetAppInfo;
    CreateHandleFile(list_hf, CL_LF);
    if NoError(GetDemoFolder) then begin
        if NoError(InitConnections) then begin
            dataresfile := HOpenResFile(app_fs.vRefNum, app_fs.parID, 'FetchNews Data', fsRdPerm); {GetGlobalStr(data_filename_index)}
            if dataresfile = -1 then begin
                FailError(-1);
            end
            else begin
                InitCursor;
                host := GetIndStr(data_strh_id, host_index);
                quitNow := not NoError(FindAddress(cp, host, nil));

                while not quitNow do begin
                    WNE;
                    HCE;
                end;

            end;
            FinishEverything;
        end;
    end;
    DestroyHandleFile(list_hf);
{    writeln(error);}
end.